{
  Copyright 2012 Sergey Ostanin

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
}

unit Script;

interface

uses
  Windows, Classes, SysUtils, uPSCompiler, uPSDebugger, uPSRuntime, uPSUtils,
  MiscUtils, Math, SecureRandom, TestCore, Modifiers, LConvEncoding;

type
  TCompiledPascalScript = class
  private
    FByteCode: String;
    FDebugInfo: String;
  end;

  TScriptModifier = class(TModifier)
  private
    FScript: TStringList;
    FCompiledScript: TCompiledPascalScript;
  public
    constructor Create; override;
    destructor Destroy; override;
    class function GetTitle: String; override;
    procedure GetScript(Script: TStrings);
    procedure SetScript(Script: TStrings);
    procedure Apply(var Question: TQuestion; Alterants: TAlterantList); override;
    procedure Assign(Source: TModifier); override;
  end;

  TVariableType = (vrtString, vrtInt64, vrtDouble);

  TVariable = class
  private
    FName: String;
    FVariableType: TVariableType;
    FStringValue: String;
    FInt64Value: Int64;
    FDoubleValue: Double;
    procedure Clear;
    function GetStringValue: String;
    procedure SetStringValue(const Value: String);
    procedure CheckType(RequiredType: TVariableType);
    function GetInt64Value: Int64;
    procedure SetInt64Value(const Value: Int64);
    function GetDoubleValue: Double;
    procedure SetDoubleValue(const Value: Double);
    function GetText: String;
  public
    constructor Create;

    property DoubleValue: Double read GetDoubleValue write SetDoubleValue;
    property Int64Value: Int64 read GetInt64Value write SetInt64Value;
    property Name: String read FName write FName;
    property StringValue: String read GetStringValue write SetStringValue;
    property Text: String read GetText;
    property VariableType: TVariableType read FVariableType;
  end;
  TVariableList = TGenericObjectList<TVariable>;

  TExpandVariablesAlterant = class(TAlterant)
  private
    FVariableList: TVariableList;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Apply(var Question: TQuestion); override;

    property VariableList: TVariableList read FVariableList;
  end;

function CompilePascalScript(Script: TStrings): TCompiledPascalScript;
procedure ExecutePascalScript(CompiledScript: TCompiledPascalScript; VariableList: TVariableList);

implementation

resourcestring
  SCompileError = 'Script compilation error:' + LineEnding + '%s';
  SExecutionError = 'Script execution error:' + LineEnding + '%s';
  SScriptTimedOut = 'Script timed out.';
  SScript = 'Script';

const
  SCRIPT_TIMEOUT = 5000;

type
  TStringConverter = function(const s: String): String;

const
  Utf8ToScriptEncoding: TStringConverter = UTF8ToCP1251;
  ScriptEncodingToUtf8: TStringConverter = CP1251ToUTF8;

function RandomInt(Range: Integer): Integer;
begin
  Result := SecureRandomInteger(Range);
end;

function RandomFloat: Extended;
begin
  Result := SecureRandomFloat;
end;

procedure Error(const Msg: String);
begin
  raise Exception.Create(Msg);
end;

function CalcPower(const Base, Exponent: Extended): Extended;
begin
  Result := power(Base, Exponent);
end;

function CalcExp(x: Extended): Extended;
begin
  Result := Exp(x);
end;

function CalcLn(x: Extended): Extended;
begin
  Result := Ln(x);
end;

function CalcRound(x: Extended): Longint;
{ Round to nearest, round half away from zero. }
begin
  if x > 0 then
    Result := Trunc(x+0.5)
  else
    Result := Trunc(x-0.5);
end;

function FloatToString(Value: Extended; DecimalDigits: Integer): String;
begin
  Result := ConvertFloatToString(Value, DecimalDigits, GetUiDecimalSeparator);
end;

function ScriptAnsiUpperCase(s: String): String;
begin
  Result := Utf8ToScriptEncoding(ToUpperUtf8(ScriptEncodingToUtf8(s)));
end;

function ScriptAnsiLowerCase(s: String): String;
begin
  Result := Utf8ToScriptEncoding(ToLowerUtf8(ScriptEncodingToUtf8(s)));
end;

function CompilerUses(Sender: TPSPascalCompiler;
  const Name: String): Boolean;
var
  DoubleType: TPSType;
begin
  if Name = 'SYSTEM' then
  begin
    DoubleType := Sender.FindType('Double');
    Assert( DoubleType <> nil );
    Sender.AddTypeCopy('Real', DoubleType);

    Sender.AddDelphiFunction('function Random(Range: Integer): Integer;');
    Sender.AddDelphiFunction('function RandomFloat: Extended;');
    Sender.AddDelphiFunction('function FloatToString(Value: Extended; DecimalDigits: Integer): String;');
    Sender.AddDelphiFunction('procedure Error(const Msg: String);');
    Sender.AddDelphiFunction('function Power(const Base, Exponent: Extended): Extended;');
    Sender.AddDelphiFunction('function Exp(x: Extended): Extended;');
    Sender.AddDelphiFunction('function Ln(x: Extended): Extended;');
    Result := TRUE;
  end
  else
    raise Exception.CreateFmt('Unit "%s" not found.', [Name]);
end;

function CompilePascalScript(Script: TStrings): TCompiledPascalScript;
var
  Compiler: TPSPascalCompiler;
  Msg: String;
begin
  Result := TCompiledPascalScript.Create;
  try
    Compiler := TPSPascalCompiler.Create;
    try
      Compiler.BooleanShortCircuit := TRUE;
      Compiler.OnUses := CompilerUses;
      if not Compiler.Compile(Utf8ToScriptEncoding(Script.Text)) then
      begin
        if Compiler.MsgCount > 0 then
          Msg := Compiler.Msg[Compiler.MsgCount-1].MessageToString
        else
          Msg := '<unknown error>';
        raise Exception.CreateFmt(SCompileError, [Msg]);
      end;
      if not Compiler.GetOutput(Result.FByteCode) then
        raise Exception.Create('Can''t get compiler output.');
      if not Compiler.GetDebugOutput(Result.FDebugInfo) then
        raise Exception.Create('Can''t get compiler debug output.');
    finally
      Compiler.Free;
    end;
  except
    Result.Free;
    raise;
  end;
end;

procedure ExecRunLine(Sender: TPSExec);
begin
  {$HINTS OFF}
  if GetIntervalSince(Cardinal(Sender.Id)) > SCRIPT_TIMEOUT then
  {$HINTS ON}
    raise Exception.Create(SScriptTimedOut);
end;

procedure ExecutePascalScript(CompiledScript: TCompiledPascalScript; VariableList: TVariableList);
var
  Exec: TPSDebugExec;
  i: Integer;
  p: PPSVariant;
  v: TVariable;
  ValueAssigned: Boolean;
begin
  VariableList.Clear;
  Exec := TPSDebugExec.Create;
  try
    Exec.RegisterDelphiFunction(@RandomInt, 'Random', cdRegister);
    Exec.RegisterDelphiFunction(@RandomFloat, 'RandomFloat', cdRegister);
    Exec.RegisterDelphiFunction(@FloatToString, 'FloatToString', cdRegister);
    Exec.RegisterDelphiFunction(@Error, 'Error', cdRegister);
    Exec.RegisterDelphiFunction(@CalcPower, 'Power', cdRegister);
    Exec.RegisterDelphiFunction(@CalcExp, 'Exp', cdRegister);
    Exec.RegisterDelphiFunction(@CalcLn, 'Ln', cdRegister);
    Exec.RegisterDelphiFunction(@CalcRound, 'Round', cdRegister); { supersede }
    Exec.RegisterDelphiFunction(@ScriptAnsiUpperCase, 'AnsiUpperCase', cdRegister); { supersede }
    Exec.RegisterDelphiFunction(@ScriptAnsiLowerCase, 'AnsiLowerCase', cdRegister); { supersede }

    if not Exec.LoadData(CompiledScript.FByteCode) then
      raise Exception.Create('Can''t load compiled bytecode.');
    Exec.LoadDebugData(CompiledScript.FDebugInfo);
    Exec.OnRunLine := ExecRunLine;
    {$HINTS OFF}
    Exec.Id := Pointer(GetTickCount);
    {$HINTS ON}
    if not Exec.RunScript then
      raise Exception.CreateFmt(SExecutionError, [PSErrorToString(Exec.ExceptionCode,
        ScriptEncodingToUtf8(Exec.ExceptionString))]);

    Assert( Exec.GetVarCount = Exec.GlobalVarNames.Count );
    for i := 0 to Exec.GetVarCount-1 do
    begin
      p := Exec.GetVarNo(i);
      if (p <> nil) and (p.FType.ClassType = TPSTypeRec) then
      begin
        v := TVariable.Create;
        try
          v.Name := Exec.GlobalVarNames[i];
          ValueAssigned := TRUE;
          case p.FType.BaseType of
            btU8: v.Int64Value := PPSVariantU8(p).Data;
            btS8: v.Int64Value := PPSVariantS8(p).Data;
            btU16: v.Int64Value := PPSVariantU16(p).Data;
            btS16: v.Int64Value := PPSVariantS16(p).Data;
            btU32: v.Int64Value := PPSVariantU32(p).Data;
            btS32: v.Int64Value := PPSVariantS32(p).Data;
            btSingle: v.DoubleValue := PPSVariantSingle(p).Data;
            btDouble: v.DoubleValue := PPSVariantDouble(p).Data;
            btExtended: v.DoubleValue := PPSVariantExtended(p).Data;
            btString: v.StringValue := ScriptEncodingToUtf8(PPSVariantAString(p).Data);
            btS64: v.Int64Value := PPSVariantS64(p).Data;
            btChar: v.StringValue := ScriptEncodingToUtf8(PPSVariantAChar(p).Data);
            else
              ValueAssigned := FALSE;
          end;
        except
          v.Free;
          raise;
        end;
        if ValueAssigned then
          VariableList.AddSafely(v)
        else
          v.Free;
      end;
    end;
  finally
    Exec.Free;
  end;
end;

{ TScriptModifier }

procedure TScriptModifier.Apply(var Question: TQuestion; Alterants: TAlterantList);
var
  Alterant: TExpandVariablesAlterant;
  i, ReplaceCount: Integer;
  v: TVariable;
  VariableList: TVariableList;
begin
  VariableList := TVariableList.Create;
  try
    if FCompiledScript = nil then
      FCompiledScript := CompilePascalScript(FScript);

    ExecutePascalScript(FCompiledScript, VariableList);

    Alterant := TExpandVariablesAlterant.Create;
    try
      i := 0;
      while i < VariableList.Count do
      begin
        v := VariableList[i];
        ReplaceCount := Question.ReplaceString(Format('$(%s)', [v.Name]), v.Text);
        if ReplaceCount > 0 then
        begin
          VariableList.Extract(v);
          Alterant.VariableList.AddSafely(v);
        end
        else
          Inc(i);
      end;
    except
      Alterant.Free;
      raise;
    end;

    if Alterant.VariableList.Count > 0 then
      Alterants.Add(Alterant)
    else
      Alterant.Free;
  finally
    VariableList.Free;
  end;
end;

procedure TScriptModifier.Assign(Source: TModifier);
begin
  inherited;
  FreeAndNil(FCompiledScript);
  FScript.Assign((Source as TScriptModifier).FScript);
end;

constructor TScriptModifier.Create;
begin
  inherited;
  FScript := TStringList.Create;
  FScript.Add('begin');
  FScript.Add('');
  FScript.Add('end.');
end;

destructor TScriptModifier.Destroy;
begin
  FreeAndNil(FScript);
  FreeAndNil(FCompiledScript);
  inherited;
end;

class function TScriptModifier.GetTitle: String;
begin
  Result := SScript;
end;

procedure TScriptModifier.GetScript(Script: TStrings);
begin
  Script.AddStrings(FScript);
end;

procedure TScriptModifier.SetScript(Script: TStrings);
begin
  FreeAndNil(FCompiledScript);
  FScript.Assign(Script);
end;

{ TVariable }

procedure TVariable.CheckType(RequiredType: TVariableType);
begin
  if RequiredType <> FVariableType then
    raise Exception.CreateFmt('Variable type mismatch: expected %d, found %d.',
      [Ord(RequiredType), Ord(FVariableType)]);
end;

procedure TVariable.Clear;
begin
  FStringValue := '';
  FDoubleValue := 0;
  FInt64Value := 0;
end;

constructor TVariable.Create;
begin
  inherited;
  FVariableType := vrtString;
end;

function TVariable.GetDoubleValue: Double;
begin
  CheckType(vrtDouble);
  Result := FDoubleValue;
end;

function TVariable.GetInt64Value: Int64;
begin
  CheckType(vrtInt64);
  Result := FInt64Value;
end;

function TVariable.GetStringValue: String;
begin
  CheckType(vrtString);
  Result := FStringValue;
end;

function TVariable.GetText: String;
begin
  case FVariableType of
    vrtString: Result := FStringValue;
    vrtInt64: Result := IntToStr(FInt64Value);
    vrtDouble: Result := ConvertFloatToString(FDoubleValue, 3, GetUiDecimalSeparator);
    else
      raise Exception.CreateFmt('Unknown variable type %d.', [Ord(FVariableType)]);
  end;
end;

procedure TVariable.SetDoubleValue(const Value: Double);
begin
  Clear;
  FVariableType := vrtDouble;
  FDoubleValue := Value;
end;

procedure TVariable.SetInt64Value(const Value: Int64);
begin
  Clear;
  FVariableType := vrtInt64;
  FInt64Value := Value;
end;

procedure TVariable.SetStringValue(const Value: String);
begin
  Clear;
  FVariableType := vrtString;
  FStringValue := Value;
end;

{ TExpandVariablesAlterant }

procedure TExpandVariablesAlterant.Apply(var Question: TQuestion);
var
  v: TVariable;
begin
  for v in FVariableList do
    Question.ReplaceString(Format('$(%s)', [v.Name]), v.Text);
end;

constructor TExpandVariablesAlterant.Create;
begin
  inherited;
  FVariableList := TVariableList.Create;
end;

destructor TExpandVariablesAlterant.Destroy;
begin
  FreeAndNil(FVariableList);
  inherited;
end;

initialization

  ModifierRegistry.Add(TScriptModifier);

end.
